home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scdebug.sc < prev    next >
Text File  |  1991-10-11  |  11KB  |  313 lines
  1. ;;; This module contains code for tracing and breakpointing functions using
  2. ;;; the SCHEME->C interpreter.  It also contains the code for an error
  3. ;;; handler which back traces the control stack.
  4.  
  5. ;*              Copyright 1989 Digital Equipment Corporation
  6. ;*                         All Rights Reserved
  7. ;*
  8. ;* Permission to use, copy, and modify this software and its documentation is
  9. ;* hereby granted only under the following terms and conditions.  Both the
  10. ;* above copyright notice and this permission notice must appear in all copies
  11. ;* of the software, derivative works or modified versions, and any portions
  12. ;* thereof, and both notices must appear in supporting documentation.
  13. ;*
  14. ;* Users of this software agree to the terms and conditions set forth herein,
  15. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  16. ;* right and license under any changes, enhancements or extensions made to the
  17. ;* core functions of the software, including but not limited to those affording
  18. ;* compatibility with other hardware or software environments, but excluding
  19. ;* applications which incorporate this software.  Users further agree to use
  20. ;* their best efforts to return to Digital any such changes, enhancements or
  21. ;* extensions that they make and inform Digital of noteworthy uses of this
  22. ;* software.  Correspondence should be provided to Digital at:
  23. ;* 
  24. ;*                       Director of Licensing
  25. ;*                       Western Research Laboratory
  26. ;*                       Digital Equipment Corporation
  27. ;*                       100 Hamilton Avenue
  28. ;*                       Palo Alto, California  94301  
  29. ;* 
  30. ;* This software may be distributed (but not offered for sale or transferred
  31. ;* for compensation) to third parties, provided such third parties agree to
  32. ;* abide by the terms and conditions of this notice.  
  33. ;* 
  34. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  35. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  36. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  37. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  38. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  39. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  40. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  41. ;* SOFTWARE.
  42.  
  43. (module scdebug
  44.     (top-level
  45.     TRACED-PROCS BPT-PROCS *ARGS* *RESULT* DOTRACE TRACER
  46.     DOUNTRACE DOBPT DOUNBPT BACKTRACE *DEBUG-ON-ERROR*))
  47.  
  48. (include "repdef.sc")
  49.  
  50. ;;; Nesting level for traced and breakpointed functions.
  51.  
  52. (define TRACE-LEVEL 0)
  53.  
  54. ;;; A-lists of traced and breakpointed functions with elements:
  55. ;;; (symbol original-procedure debugged-procedure).
  56.  
  57. (define TRACED-PROCS '())
  58.  
  59. (define BPT-PROCS '())
  60.  
  61. ;;; Arguments at the time of a breakpoint are in *ARGS*, and the result is in
  62. ;;; *RESULT* after the function is called.  A new result may be returned by
  63. ;;; continuing from the breakpoint with (PROCEED new-value).
  64.  
  65. (define *ARGS* '())
  66.  
  67. (define *RESULT* '())
  68.  
  69. ;;; Function tracing
  70.  
  71. (install-expander
  72.     'TRACE
  73.      (lambda (x e)
  74.          (if (cdr x)
  75.          `(map (lambda (f) (dotrace f)) (quote ,(cdr x)))
  76.          '(map (lambda (x) (car x)) traced-procs))))
  77.  
  78. (define (DOTRACE name)
  79.     (if (assoc name traced-procs) (dountrace name))
  80.     (if (assoc name bpt-procs) (dounbpt name))
  81.     (let ((proc (top-level-value name))
  82.       (trace-proc #f))
  83.      (if (not (procedure? proc))
  84.          (error 'TRACE "Argument is not a PROCEDURE name"))
  85.      (if (assoc name traced-procs)
  86.          (error 'TRACE "~s is already traced" name))
  87.      (set! trace-proc (tracer name proc))
  88.      (set! traced-procs (cons (list name proc trace-proc) traced-procs))
  89.      (set-top-level-value! name trace-proc))
  90.     name)
  91.  
  92. (define (TRACER name proc)
  93.     (lambda x
  94.         (format stdout-port "~a~s~%"
  95.             (make-string (* 2 (min trace-level 15)) #\space)
  96.             (cons name x))
  97.         (set! trace-level (+ trace-level 1))
  98.         (let ((result (apply proc x)))
  99.          (set! trace-level (- trace-level 1))
  100.          (format stdout-port "~a~a~s~%"
  101.              (make-string (* 2 (min trace-level 15)) #\space)
  102.               "==> " result)
  103.          result)))
  104.  
  105. (install-expander
  106.     'UNTRACE
  107.     (lambda (x e)
  108.         (if (null? (cdr x))
  109.         (set! x (map (lambda (x) (car x)) traced-procs))
  110.         (set! x (cdr x)))
  111.         `(map (lambda (f) (dountrace f)) (quote ,x))))
  112.  
  113. (define (DOUNTRACE name)
  114.     (let ((name-proc-trace (assoc name traced-procs)))
  115.      (if (not name-proc-trace)
  116.          (error 'UNTRACE "~s is not traced" name))
  117.      (if (eq? (top-level-value name) (caddr name-proc-trace))
  118.          (set-top-level-value! name (cadr name-proc-trace)))
  119.      (set! traced-procs (remove name-proc-trace traced-procs)))
  120.     name)
  121.  
  122. ;;; Function breakpoints
  123.  
  124. (install-expander
  125.     'BPT
  126.      (lambda (x e)
  127.          (case (length x)
  128.            ((1) '(map (lambda (x) (car x)) bpt-procs))
  129.            ((2) `(apply dobpt (quote ,(cdr x))))
  130.            ((3) (let ((func (e (caddr x) e)))
  131.                  `(apply dobpt
  132.                      (list (quote ,(cadr x)) (quote ,func)))))
  133.            (else (error 'BPT "Illegal arguments")))))
  134.  
  135. (define (DOBPT name . condition)
  136.     (if (assoc name traced-procs) (dountrace name))
  137.     (if (assoc name bpt-procs) (dounbpt name))
  138.     (let ((proc (top-level-value name))
  139.       (bpt-proc #f))
  140.      (if (not (procedure? proc))
  141.          (error 'BPT "Argument is not a PROCEDURE name"))
  142.      (set! bpt-proc
  143.            (bpter name proc (if condition (eval (car condition)))))
  144.      (set! bpt-procs (cons (list name proc bpt-proc) bpt-procs))
  145.      (set-top-level-value! name bpt-proc))
  146.     name)
  147.  
  148. (define BPTER-PROCNAME "")
  149.      
  150. (define (BPTER name proc condition)
  151.     (define (XEQ . args)
  152.         (let ((ftok (enable-system-file-tasks #f)))
  153.          (let ((result (apply read-eval-print args)))
  154.               (enable-system-file-tasks ftok)
  155.               result)))
  156.     (lambda x
  157.         (set! bpter-procname (c-tscp-ref (stacktrace) 4))
  158.         (if (or (not condition) (apply condition x))
  159.         (let ((prompt (format "~s- " trace-level)))
  160.              (set! *args* x)
  161.              (xeq
  162.              'header
  163.              (format "~%~s -calls  - ~s" trace-level
  164.                  (cons name x))
  165.              'prompt
  166.              prompt
  167.              'env
  168.              (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f))
  169.              (set! trace-level (+ trace-level 1))
  170.              (set! *result* (apply proc *args*))
  171.              (set! trace-level (- trace-level 1))
  172.              (xeq
  173.              'header
  174.              (format "~s -returns- ~s" trace-level *result*)
  175.              'prompt
  176.              prompt
  177.              'result
  178.              *result*
  179.              'env
  180.              (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f)))
  181.         (apply proc x))))
  182.  
  183. (install-expander
  184.     'UNBPT
  185.     (lambda (x e)
  186.         (if (null? (cdr x))
  187.         (set! x (map (lambda (x) (car x)) bpt-procs))
  188.         (set! x (cdr x)))
  189.         `(map (lambda (f) (dounbpt f)) (quote ,x))))
  190.  
  191. (define (DOUNBPT name)
  192.     (let ((name-proc-bpt (assoc name bpt-procs)))
  193.      (if (not name-proc-bpt)
  194.          (error 'UNBPT "~s is not breakpointed" name))
  195.      (if (eq? (top-level-value name) (caddr name-proc-bpt))
  196.          (set-top-level-value! name (cadr name-proc-bpt)))
  197.      (set! bpt-procs (remove name-proc-bpt bpt-procs)))
  198.     name)
  199.  
  200. ;;; The following functions are used to backtrace the control stack.  The first
  201. ;;; performs an insertion sort to insert a new element into a list.
  202.  
  203. (define (INSERTION-SORT item sorted-items before?)
  204.     (let loop ((next sorted-items) (prev #f))
  205.      (cond ((null? next)
  206.         (if prev
  207.             (begin (set-cdr! prev (list item))
  208.                sorted-items)
  209.             (list item)))
  210.            ((not (before? item (car next)))
  211.         (loop (cdr next) next))
  212.            (prev
  213.         (set-cdr! prev (cons item next))
  214.         sorted-items)
  215.            (else (cons item sorted-items)))))
  216.  
  217.  
  218. ;;; Backtracing is done by the following function.  It accepts a starting
  219. ;;; function (or #F), a termination function (or #F), a line count, and an
  220. ;;; output port.  It returns an environment for use with eval with the
  221. ;;; following definitions:  all variables defined in the innermost interpreted
  222. ;;; environments, and variables of the form env-n whose value is the
  223. ;;; environment at that interpreter level.
  224.  
  225. (define (DOBACKTRACE start stop lines port)
  226.     (do ((stp (stacktrace) (c-unsigned-ref stp 0))
  227.      (procname "")
  228.      (envlist '())
  229.      (envid '(env-0 env-1 env-2 env-3 env-4 env-5 env-6 env-7 env-8
  230.           env-9 env-10 env-11 env-12 env-13 env-14 env-15 env-16
  231.           env-17 env-18 env-19))
  232.      (string-out (open-output-string)))
  233.     ((or (= stp 0)
  234.          (= lines 0)
  235.          (null? envid)
  236.          (and (not start) (equal? procname stop)))
  237.      (if envlist
  238.          (append (cdr (assq 'env-0 envlist)) envlist)
  239.          envlist))
  240.     (set! procname (c-tscp-ref stp 4))
  241.     (cond (start
  242.            (if (equal? start procname) (set! start #f)))
  243.           ((not (string? procname))
  244.            (when port
  245.                  (write (c-tscp-ref stp 8) string-out)
  246.                  (let ((expr (get-output-string string-out)))
  247.                   (if (> (string-length expr) 65)
  248.                      (display (string-append (substring expr 0 65)
  249.                           " ...") port)
  250.                      (display expr port)))
  251.               (display " in " port)
  252.                      (display (car envid) port)
  253.                      (newline port))
  254.            (set! envlist (cons (cons (car envid) procname) envlist))
  255.            (set! envid (cdr envid))
  256.            (set! lines (- lines 1)))
  257.           ((member procname
  258.                '("SCEVAL_INTERPRETED-PROC" "LOOP [inside EXEC]")))
  259.           (else
  260.            (when port
  261.              (display "(" port)
  262.                  (display procname port)
  263.                  (display " ...)" port)
  264.                  (newline port))
  265.            (set! lines (- lines 1))))))
  266.  
  267. ;;; A backtrace at a breakpoint is obtained by the following function.
  268.  
  269. (define (BACKTRACE . count)
  270.     (dobacktrace bpter-procname "READ-EVAL-PRINT" (if count (car count) 20)
  271.     stderr-port)
  272.     #f)
  273.  
  274. ;;; The default error handler is replaced by the following function when
  275. ;;; backtracing on error is desired.  It prints the backtrace, and then
  276. ;;; enters a read-eval-print loop when *DEBUG-ON-ERROR* is set.
  277.  
  278. (define *DEBUG-ON-ERROR* #f)
  279.  
  280. (define (BACKTRACE-ERROR-HANDLER id format-string . args)
  281.     (display (format "***** ~a " id) stderr-port)
  282.     (display (apply format (cons format-string args)) stderr-port)
  283.     (newline stderr-port)
  284.     (set! *error-handler* backtrace-error-handler)
  285.     (when *debug-on-error*
  286.       (let ((env (dobacktrace "ERROR" "READ-EVAL-PRINT" 20 stderr-port))
  287.         (ftok (enable-system-file-tasks #f)))
  288.            (set! *debug-on-error* #f)
  289.            (let loop () (when (char-ready? stdin-port)
  290.                   (if (not (eof-object?
  291.                            (read-char stdin-port)))
  292.                       (loop))))
  293.            (read-eval-print 'prompt ">> " 'header #f 'env env)
  294.            (enable-system-file-tasks ftok)
  295.            (set! *debug-on-error* #t)))
  296.     (reset))
  297.  
  298. ;;; Keyboard interrupt signals are handled by the following function.  If
  299. ;;; the interpreter is currently reading stdin, then this results in a reset.
  300. ;;; Otherwise, a stack trace is printed and the debugger is entered.  A normal
  301. ;;; exit from the debugger results in the Scheme computation continuing.
  302.  
  303. (define (ON-INTERRUPT sig)
  304.     (if *reading-stdin* (reset))
  305.     (let ((ftok (enable-system-file-tasks #f))
  306.       (start (c-tscp-ref
  307.              (c-unsigned-ref (c-unsigned-ref (stacktrace) 0) 0) 4)))
  308.      (format stderr-port "~%***** INTERRUPT *****~%")
  309.      (dobacktrace start "READ-EVAL-PRINT" 20 stderr-port)
  310.      (read-eval-print 'header #f 'prompt ">> "
  311.          'env (dobacktrace start "READ-EVAL-PRINT" 20 #f))
  312.      (enable-system-file-tasks ftok)))
  313.